/* Definitions for high-level IO functions.

   This file is part of khipu.

   khipu is free software: you can redistribute it and/or modify
   it under the terms of the GNU Lesser General Public License as published by
   the Free Software Foundation; either version 3 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU Lesser General Public License for more details.

   You should have received a copy of the GNU Lesser General Public License
   along with this program.  If not, see <https://www.gnu.org/licenses/>.  */

#include <cctype>
#include <cstdlib>
#include <cstdio>
#include <cstdarg>
#include <cerrno>
#include <new>

#include "khipu.hpp"
#include "utils/chmask.hpp"
#include "utils/raw_acc.hpp"

KP_DECLS_BEGIN

[[noreturn]] static inline void
raise_eos (interpreter *interp)
{
  interp->raise ("parse-error", "read: premature end of input");
}

enum
{
  TOK_NONE,
  TOK_OPEN,
  TOK_CLOSE,
  TOK_DOT, 
  TOK_SYM,
  TOK_NUM,
  TOK_CHAR,
  TOK_COMMA,
  TOK_COMMAAT,
  TOK_COMMADOT,
  TOK_BQ,
  TOK_QUOTE,
  TOK_SHARPDOT,
  TOK_LABEL,
  TOK_BACKREF,
  TOK_SHARPQUOTE, 
  TOK_SHARPOPEN, 
  TOK_OPENB,
  TOK_CLOSEB,
  TOK_OPENBRACE,
  TOK_CLOSEBRACE,
  TOK_SHARPSYM,
  TOK_GENSYM,
  TOK_DQUOTE,
  TOK_SHARPDQUOT
};

static inline bool
symchar_p (int c)
{
  static const char SPEC_CHS[] = "()[]{}'\";`,\\| \f\n\r\t\v";
  return (!memchr (SPEC_CHS, c, sizeof (SPEC_CHS) - 1));
}

static bool
numtok_p (interpreter *interp, char *tok, int len)
{
  if (*tok == '\0')
    return (false);
  else if (len == 4 && (memcmp (tok, "-INF", 4) == 0 ||
      memcmp (tok, "+INF", 4) == 0))
    {
      interp->retval = *tok == '-' ? FLT_NINF : FLT_PINF;
      return (true);
    }
  else if (len == 3 && memcmp (tok, "NaN", 3) == 0)
    {
      interp->retval = FLT_QNAN;
      return (true);
    }

  num_info info;

  if (tok[len - 1] == '.')
    tok[len++] = '0';

  if (parse_num (interp, tok, len, info) < 0)
    return (false);
  else if (info.type == typecode::INT)
    {
      int slen = info.dec_end - info.dec_start;
      int rl = invbsize (info.radix, slen) + 1;

      if (rl == 1)
        { // May fit in a fixint.
          intptr_t uval = strtoui1 (tok +
            info.dec_start, slen, info.radix);
          intptr_t val = info.sign ? -uval : uval;

          interp->retval = intobj (interp, val);
        }
      else
        {
          bigint *lp = as_bigint (alloc_bigint (interp, rl));
          lp->len = strtoui (lp->data, tok +
            info.dec_start, slen, info.radix);

#ifdef KP_ARCH_WIDE
          interp->retval = lp->as_obj () | (info.sign ? SIGN_BIT : 0);
#else
          if (info.sign)
            lp->len = -lp->len;

          interp->retval = lp->as_obj ();
#endif
        }

      return (true);
    }

  // info.type == typecode::FLOAT
  int expo, slen = info.frac_end - info.dec_start - 1;

  if (info.expo_start != 0)
    {
      uint32_t uev;

      if (invbsize (info.radix, len - info.expo_start) > 1 ||
          (uev = strtoui1 (&tok[info.expo_start], len -
            info.expo_start, info.radix)) >
          0x7fffffffu + info.expo_sign)
        interp->raise ("arith-error", "exponent "
          "too large in floating point value");

      expo = info.expo_sign ? -(int)uev : uev;
    }
  else
    expo = 0;

  if (info.frac_end != 0)
    expo -= info.frac_end - info.dec_end - info.got_dot;

  /* The maximum number of limbs to be used by 'strtolf' is the
   * sum of the limbs needed by the mantissa and radix^exponent,
   * given that it may end up multiplying them. */
  int nlimbs = invbsize (info.radix, slen) +
    invbsize (info.radix, abs (expo)) + 2;
  KP_TMARK (interp);

  limb_t *mp = (limb_t *)KP_TALLOC (interp, nlimbs * sizeof (*mp));
  memset (mp, 0, nlimbs * sizeof (*mp));

  int ret = strtolf (interp, tok, len, info, expo, mp);
  int b2exp = (expo - ret) * LIMB_BITS;

  if (b2exp >= DBL_MIN_EXP && b2exp <= DBL_MAX_EXP)
    { // See if we can fit it in a double.
      double dbl = uitodbl (mp, ret, expo);
      if (!finf_p (dbl))
        {
          interp->retval = fltobj::make (interp,
                                         info.sign ? -dbl : dbl);
          return (true);
        }
    }

  bigfloat *fp = as_bigfloat (alloc_bigfloat (interp, ret));
  memcpy (fp->data, mp, (fp->len = ret) * sizeof (*fp->data));
  fp->expo = expo;

#ifdef KP_ARCH_WIDE
  interp->retval = fp->as_obj () | (info.sign ? SIGN_BIT : 0);
#else
  if (info.sign)
    fp->len = -fp->len;

  interp->retval = fp->as_obj ();
#endif

  return (true);
}

static const struct
{
  const char *name;
  uint32_t value;
} CHAR_NAMES[] =
{
  { "lf", '\n'  },
  { "tab", '\t' },
  { "sp", ' ' },
  { "nil", '\0' },
  { "bell", '\a' },
  { "back", '\b' },
  { "ret", '\r' },
  { "vtab", '\v' }
};

const char* chobj_repr (uint32_t ch)
{
  for (size_t i = 0; i < KP_NELEM (CHAR_NAMES); ++i)
    if (ch == CHAR_NAMES[i].value)
      return (CHAR_NAMES[i].name);

  return (nullptr);
}

reader::reader (interpreter *ip, object input, package *pkg) : interp (ip),
  pairs_valref (ip, fixint (0)), ipkg (pkg)
{
  this->pairs.local_init (this->stpairs, KP_NELEM (this->stpairs));

  this->pair_cnt = 0;
  for (uint32_t i = 0; i < this->pairs.len; ++i)
    this->pairs.data[i] = UNBOUND;

  this->bufmax = KP_NELEM (this->stbuf);
  this->bufp = this->stbuf;

  this->take ();
  this->src = as_stream (input);
  *this->pairs_valref = this->pairs.as_obj ();

  if (!this->ipkg)
    this->ipkg = as_package (ip->xpkg);
}

void reader::take ()
{
  this->toktype = TOK_NONE;
  this->bufcnt = 0;
}

void reader::push_ch (const schar& ch)
{
  if (this->bufcnt + ch.len >= this->bufmax)
    {
      int nsize = (int)upsize (this->bufcnt + ch.len + 1);
      char *nbuf = (char *)xmalloc (nsize);

      memcpy (nbuf, this->bufp, this->bufcnt);
      if (this->bufp != this->stbuf)
        xfree (this->bufp);

      this->bufp = nbuf;
      this->bufmax = nsize;
    }

  fscpy (this->bufp + this->bufcnt, ch.buf, ch.len);
  this->bufcnt += ch.len;
}

bool reader::read_token (schar& ch, int digs)
{
  bool first = true;
  int esc_p = 0, sym_p = 0;
  while (true)
    {
      if (!first && !this->src->sgetc (this->interp, ch))
        goto term;

      first = false;
      if (ch.uc == '|')
        esc_p ^= (sym_p = 1);
      else if (ch.uc == '\\')
        {
          sym_p = 1;
          if (!this->src->sgetc (this->interp, ch))
            goto term;

          this->push_ch (ch);
        }
      else if (!esc_p && (!symchar_p (ch.uc) &&
          (!digs || isdigit (ch.uc))))
        break;
      else
        this->push_ch (ch);
    }

  this->src->ungetuc (ch.buf, ch.len);
term:
  this->bufp[this->bufcnt] = '\0';
  return (sym_p != 0);
}

void reader::expand ()
{
  object *p2 = (object *)xmalloc (this->pairs.len * 2);
  copy_objs (p2, this->pairs.data, this->pairs.len);

  this->pairs.len *= 2;
  if (this->pairs.data != this->stpairs)
    xfree (this->pairs.data);

  this->pairs.data = p2;
}

object reader::getlbl (object lbl) const
{
  for (uint32_t i = 0; i < this->pair_cnt; i += 2)
    if (this->pairs.data[i] == lbl)
      return (this->pairs.data[i + 1]);

  return (UNBOUND);
}

object* reader::putlbl (object lbl)
{
  for (uint32_t i = 0; i < this->pair_cnt; i += 2)
    if (this->pairs.data[i] == UNBOUND)
      {
        this->pairs.data[i] = lbl;
        return (&this->pairs.data[i + 1]);
      }
    else if (this->pairs.data[i] == lbl)
      return (&this->pairs.data[i + 1]);

  if (this->pair_cnt == this->pairs.len)
    this->expand ();

  this->pairs.data[this->pair_cnt++] = lbl;
  return (&this->pairs.data[this->pair_cnt]);
}

bool reader::nextc (schar& ch)
{
  do
    {
      if (!this->src->sgetc (this->interp, ch))
        return (false);
      else if (ch.uc == ';')
        do
          if (!this->src->sgetc (this->interp, ch))
            return (false);
        while (ch.uc != '\n');

      if (ch.uc == '\n')
        ++this->lineno;
    }
  while (isspace (ch.uc));

  return (true);
}

static inline bool
check_symname (interpreter *interp, const char *name, int len)
{
  num_info info;
  return (parse_num (interp, name, len, info) < 0);
}

static void
update_pkg_expr (interpreter *interp, const char *sname,
  const char *uptr, const char *uend, object& out)
{
  valref key (interp, symbol::make_kword (interp, uptr, uend - uptr));

  if (out == UNBOUND)
    out = KP_CALL (interp, list_fct,
                   intern (interp, sname, (uptr - sname) - 2), *key);
  else
    {
      *key = cons::make (interp, *key, NIL);
      out = cons::make (interp, out, *key);
    }
}

static object
make_pkg_expr (interpreter *interp, object name, object ipkg)
{
  /* Transform a symbol name of the kind 'a::b::c' into its equivalent
   * expression: ((a :b) :c).
   * This is required when the symbol can't be resolved at read-time,
   * and is therefore delegated to a runtime lookup. */
  const char *sname = str_cdata (name);
  int len = as_str(name)->nbytes;
  valref_head h (interp);
  fast_valref ret (interp, UNBOUND), key (interp, UNBOUND);

  while (true)
    {
      auto uptr = (const char *)memchr (sname, ':', len);
      if (!uptr)
        { // Last name - Append and we're out.
          *key = cons::make (interp,
                             symbol::make_kword (interp, sname, len), NIL);
          *ret = cons::make (interp, *ret, *key);
          break;
        }
      else if (uptr[1] != *uptr)
        interp->raise ("parse-error",
          KP_SPRINTF (interp, "read: invalid symbol name: %Q", name));

      auto u2 = (const char *)memchr (uptr + 2, ':', (sname + len - 2) - uptr);
      if (!u2)
        {
          update_pkg_expr (interp, sname, uptr + 2, sname + len, *ret);
          break;
        }
      else if (u2[1] != *u2)
        interp->raise ("parse-error",
          KP_SPRINTF (interp, "read: invalid symbol name: %Q", name));

      update_pkg_expr (interp, sname, uptr + 2, u2, *ret);
      len -= (u2 + 2) - sname;
      sname = u2 + 2;
    }

  kp_return (*ret);
}

void reader::handle_sym (object pkg, object name)
{
  valref_head h (interp);
  fast_valref xpkg (interp, pkg), tmp (interp, UNBOUND);
  const char *sname = str_cdata (name);
  int len = as_str(name)->nbytes;

  while (true)
    {
      auto uptr = (const char *)memchr (sname, ':', len);
      if (!uptr)
        {
          intern (this->interp, sname, len, as_package (*xpkg));
          return;
        }
      else if (uptr[1] != *uptr ||
          !check_symname (interp, sname, uptr - sname))
        this->interp->raise ("parse-error",
          KP_SPRINTF (interp, "read: invalid symbol name: %Q", name));

      *tmp = find_sym (interp, *xpkg, sname, uptr - sname);
      *tmp = !symbol_p (*tmp) ? UNBOUND : symval (*tmp);

      if (*tmp != UNBOUND && package_p (*tmp))
        // Still reachable at read-time - Update the current package.
        *xpkg = *tmp;
      else
        {
          make_pkg_expr (interp, name, *xpkg);
          return;
        }

      len -= (uptr + 2) - sname;
      sname = uptr + 2;
    }
}

uint32_t reader::peek ()
{
  schar ch;
  if (this->toktype != TOK_NONE)
    return (this->toktype);
  else if (!this->nextc (ch))
    return (TOK_NONE);

  switch (ch.uc)
    {
#define DISPATCH(ch, tok)   \
  case ch:   \
    this->toktype = TOK_##tok;   \
    break

      DISPATCH ('(', OPEN);
      DISPATCH (')', CLOSE);
      DISPATCH ('[', OPENB);
      DISPATCH (']', CLOSEB);
      DISPATCH ('{', OPENBRACE);
      DISPATCH ('}', CLOSEBRACE);
      DISPATCH ('\'', QUOTE);
      DISPATCH ('`', BQ);
      DISPATCH (',', COMMA);
      DISPATCH ('"', DQUOTE);
      DISPATCH ('\\', CHAR);
          
      case '#':
        {
          if (!this->src->sgetc (this->interp, ch))
            this->interp->raise ("parse-error", "read: invalid read macro");
          else if (ch.uc == '.')
            this->toktype = TOK_SHARPDOT;
          else if (ch.uc == '\'')
            this->toktype = TOK_SHARPQUOTE;
          else if (ch.uc == '(')
            this->toktype = TOK_SHARPOPEN;
          else if (ch.uc == '<')
            this->interp->raise ("parse-error", "read: unreadable object");
          else if (ch.uc == ':')
            {
              if (!this->src->sgetc (this->interp, ch))
                raise_eos (this->interp);

              this->read_token (ch, 0);
              if (numtok_p (interp, this->bufp, this->bufcnt))
                this->interp->raise ("parse-error",
                  "read: invalid syntax after #: reader macro");

              this->toktype = TOK_SYM;
              this->interp->push (alloc_sym (interp));
              symname(interp->stktop ()) =
                string::make (interp, this->bufp, this->bufcnt);
              this->interp->pop ();
            }
          else if (isdigit (ch.uc))
            {
              this->read_token (ch, 1);
              this->src->sgetc (this->interp, ch);

              if (ch.uc == '#')
                this->toktype = TOK_BACKREF;
              else if (ch.uc == '=')
                this->toktype = TOK_LABEL;
              else
                this->interp->raise ("parse-error", "read: invalid label");

              errno = 0;
              char *endp;
              long xv = strtol (bufp, &endp, 10);
              if (*endp != '\0' || errno != 0)
                this->interp->raise ("parse-error", "read: invalid label");

              this->interp->retval = fixint (xv);
            }
          else if (ch.uc == '!')
            {
              do
                this->src->sgetc (this->interp, ch);
              while (ch.uc != UEOF && ch.uc != '\n');

              return (this->peek ());
            }
          else if (ch.uc == '"')
            this->toktype = TOK_SHARPDQUOT;
          else if (ch.uc == '|')
            {
              for (int lvl = 1 ; ; )
                {
                  this->src->sgetc (this->interp, ch);
                got_hashp:
                  if (ch.uc == UEOF)
                    raise_eos (this->interp);
                  else if (ch.uc == '|')
                    {
                      this->src->sgetc (this->interp, ch);
                      if (ch.uc == '#')
                        {
                          if (--lvl == 0)
                            break;

                          continue;
                        }

                      goto got_hashp;
                    }
                  else if (ch.uc == '#')
                    {
                      this->src->sgetc (this->interp, ch);
                      if (ch.uc == '|')
                        ++lvl;
                      else
                        goto got_hashp;
                    }
                }

              return (this->peek ());
            }
          else if (ch.uc == '\\')
            { // #\x => (intern ',(symname x))
              object sym = this->read_sexpr (UNBOUND);
              if (!symbol_p (sym))
                this->interp->raise ("type-error",
                                     "expected a symbol after read macro #\\");

              valref tmp (interp, sym);
              alloc_cons (this->interp, 2);
              xcar(this->interp->alval) = symbol::quote;
              xcadr(this->interp->alval) = symname (*tmp);

              *tmp = this->interp->alval;
              alloc_cons (this->interp, 2);
              xcar(this->interp->alval) = intern (this->interp, "intern", 6);
              xcadr(this->interp->alval) = *tmp;
              this->interp->retval = this->interp->alval;
              this->toktype = TOK_SYM;
            }
          else
            this->interp->raise ("parse-error", "read: unknown read macro");

          break;
        }

      default:
        // Number or symbol.
        if (!this->read_token (ch, 0))
          {
            if (*this->bufp == '.' && this->bufp[1] == '\0')
              return (this->toktype = TOK_DOT);
            else if (numtok_p (interp, this->bufp, this->bufcnt))
              return (this->toktype = TOK_NUM);
          }

        this->toktype = TOK_SYM;
        if (*this->bufp == ':')
          {
            if (this->bufcnt > 1 && this->bufp[1] == ':')
              {
                local_varobj<string> nm;
                nm.local_init (this->bufp + 2);
                this->handle_sym (root_package, nm.as_obj ());
              }
            else
              symbol::make_kword (this->interp, this->bufp + 1);
          }
        else
          {
            local_varobj<string> nm;
            nm.local_init (this->bufp);
            this->handle_sym (this->ipkg->as_obj (), nm.as_obj ());
          }

        break;
    }

#undef DISPATCH
  return (this->toktype);
}

object reader::read_array (object lbl)
{
  object dummy, *dstp = lbl != UNBOUND ? this->putlbl (lbl) : &dummy;
  raw_acc<array> ar (3);

  *dstp = ar.as_obj ();
  while (this->peek () != TOK_CLOSEB)
    {
      if (!this->readable_p ())
        raise_eos (this->interp);

      ar.add_obj (this->read_sexpr (UNBOUND));
    }

  this->take ();
  this->interp->retval = ar.as_obj ();

  array *ap = ar.release ();
  if (ap->len > 0)
    gc_register (this->interp, ap, sizeof (*ap) + ar.alloc);
  else
    {
      xfree (ap);
      this->interp->retval = alloc_array (this->interp, 0);
    }

  return (this->interp->retval);
}

object reader::read_table (object)
{
  sp_guard sg (this->interp);
  // Push equality and hash functions.
  this->interp->push (NIL);
  this->interp->push (NIL);

  while (this->peek () != TOK_CLOSEBRACE)
    {
      if (!this->readable_p ())
        raise_eos (this->interp);

      this->interp->push (this->read_sexpr (UNBOUND));
    }

  this->take ();
  return (table_fct (this->interp, this->interp->stack + sg.sp,
    this->interp->stklen () - sg.sp));
}

object reader::read_tuple (object lbl)
{
  object dummy, *dstp = lbl != UNBOUND ? this->putlbl (lbl) : &dummy;
  valref_head h (interp);
  fast_valref ret (this->interp, alloc_tuple (this->interp, NIL)),
              key (this->interp, NIL);

  for (*dstp = *ret; this->peek () != TOK_CLOSE; )
    {
      if (!this->readable_p ())
        raise_eos (this->interp);

      *key = this->read_sexpr (UNBOUND);
      tuple_put (interp, *ret, *key, false);
    }

  this->take ();
  kp_return (*ret);
}

static inline int
escape_char (int ch)
{
  if (ch == 'n')
    return ('\n');
  else if (ch == 't')
    return ('\t');
  else if (ch == 'r')
    return ('\r');
  else if (ch == 'a')
    return ('\a');
  else if (ch == 'b')
    return ('\b');
  else if (ch == '\\' || ch == '"')
    return (ch);
  else if (ch == '0')
    return (0);
  else
    return (-1);
}

[[noreturn]] static inline void
raise_eilseq (interpreter *interp, const char *seq)
{
  char buf[100];
  sprintf (buf, "read: invalid escape sequence: %s", seq);
  interp->raise ("parse-error", buf);
}

object reader::read_bvector ()
{
  raw_acc<bvector> bv (8);
  char ebuf[8];

  for (ebuf[0] = '\\' ; ; )
    {
      int byte = this->src->getb (this->interp);

      if (byte < 0)
        raise_eos (this->interp);
      else if (byte == '"')
        break;
      else if (byte == '\\')
        {
          int b1 = 0, b2 = 0;

          if ((byte = this->src->getb (this->interp)) < 0)
            raise_eos (this->interp);
          else if (byte == 'x')
            {
              b1 = this->src->getb (this->interp);
              b2 = this->src->getb (this->interp);

              if ((b1 | b2) < 0)
                raise_eos (this->interp);
              else if (!isxdigit (b1) || !isxdigit (b2))
                {
                  ebuf[1] = 'x', ebuf[2] = b1;
                  ebuf[3] = b2, ebuf[4] = 0;
                  raise_eilseq (this->interp, ebuf);
                }

              byte = (b1 - '0') * 16 + (b2 - '0');
            }
          else if ((byte = escape_char (byte)) < 0)
            {
              ebuf[1] = byte, ebuf[2] = 0;
              raise_eilseq (this->interp, ebuf);
            }
        }

      bv.add_data (&byte, 1);
    }

  bvector *ret = bv.release ();

  if (ret->nbytes > 0)
    {
      this->interp->retval = ret->as_obj ();
      ret->data[ret->nbytes] = 0;
      gc_register (this->interp, ret, sizeof (*ret) + bv.alloc);
    }
  else
    {
      xfree (ret);
      this->interp->retval = alloc_bvector (this->interp, 0);
    }

  return (this->interp->retval);
}

object reader::read_str ()
{
  raw_acc<string> str (8);
  char buf[16];

  as_str(str.as_obj ())->hval = 0;
  as_str(str.as_obj ())->len = 0;

  for (buf[0] = '\\' ; ; )
    {
      schar ch;

      if (!this->src->sgetc (this->interp, ch))
        raise_eos (this->interp);
      else if (ch.uc == '"')
        break;
      else if (ch.uc == '\\')
        {
          int n;

          if (!this->src->sgetc (this->interp, ch))
            raise_eos (this->interp);
          else if ((ch.uc == 'x' && (n = 2)) ||
              (ch.uc == 'u' && (n = 4)) ||
              (ch.uc == 'U' && (n = 8)))
            {
              buf[1] = ch.uc;

              for (int i = 0; i < n; ++i)
                {
                  if (!this->src->sgetc (this->interp, ch))
                    raise_eos (this->interp);

                  buf[2 + i] = *ch.buf;
                  if (!isxdigit (*ch.buf))
                    {
                      buf[3 + i] = 0;
                      raise_eilseq (this->interp, buf);
                    }
                }

              buf[2 + n] = 0;
              ch.uc = strtol (&buf[2], nullptr, 16);
              if (ch.uc > MAX_CHAR)
                raise_eilseq (this->interp, buf);

              ch.len = u32tou8 ((unsigned char *)ch.buf, ch.uc);
            }
          else
            {
              if ((n = escape_char (ch.uc)) < 0)
                {
                  buf[1] = 'X', buf[2 + ch.len] = 0;
                  memcpy (&buf[2], ch.buf, ch.len);
                  raise_eilseq (this->interp, buf);
                }

              *ch.buf = n, ch.len = 1;
            }
        }

      str.add_data (ch.buf, ch.len);
      ++as_str(str.as_obj ())->len;
    }

  string *sp = str.release ();

  if (sp->len > 0)
    {
      sp->vo_full |= FLAGS_CONST;
      this->interp->retval = sp->as_obj ();
      sp->data[sp->nbytes] = '\0';
      gc_register (this->interp, sp, sizeof (*sp) + str.alloc);
    }
  else
    {
      xfree (sp);
      this->interp->retval = alloc_str (this->interp, 0);
    }

  return (this->interp->retval);
}

object reader::read_char ()
{
  schar cv;

  for (bool got = false ; ; got = true)
    {
      schar tmp;
      if (!this->src->sgetc (this->interp, tmp))
        raise_eos (this->interp);
      else if (tmp.uc <= 0x7f && !symchar_p (tmp.uc) && got)
        {
          this->src->ungetuc (tmp.buf, tmp.len);
          this->bufp[this->bufcnt] = '\0';
          break;
        }
      else if (!isspace (tmp.uc) && (symchar_p (tmp.uc) || !got))
        {
          if (!got)
            cv = tmp;
          this->push_ch (tmp);
        }
      else if (!got)
        interp->raise ("parse-error", "read: empty character designator");
      else
        {
          this->bufp[this->bufcnt] = '\0';
          break;
        }
    }

  local_varobj<string> sn;

  if (this->bufp[1] == '\0')
    ;
  else if (cv.uc == 'u' || cv.uc == 'U' || cv.uc == 'x')
    {
      long rv = strtol (this->bufp + 1, 0, 16);
      if (errno != 0 || rv >= (long)MAX_CHAR)
        this->interp->raise ("parse-error",
          "read: invalid unicode constant");

      cv.uc = (uint32_t)rv;
    }
  else if (cv.uc >= 'a' && cv.uc <= 'z')
    {
      cv.uc = ~0u;
      for (size_t i = 0; i < KP_NELEM (CHAR_NAMES); ++i)
        if (strcmp (this->bufp, CHAR_NAMES[i].name) == 0)
          {
            cv.uc = CHAR_NAMES[i].value;
            break;
          }

      if (cv.uc == ~0u)
        {
          sn.local_init (this->bufp);
          this->interp->raise ("parse-error",
            KP_SPRINTF (this->interp, "read: unknown character: \\%Q",
                        sn.as_obj ()));
        }
    }
  else
    {
      sn.local_init (this->bufp);
      this->interp->raise ("parse-error",
        KP_SPRINTF (this->interp, "read: unknown character: \\%Q",
                    sn.as_obj ()));
    }

  this->take ();
  kp_return (charobj (cv.uc));
}

object reader::read_list (object lbl)
{
  object dummy, *dstp = lbl != UNBOUND ? this->putlbl (lbl) : &dummy;
  valref_head h (interp);
  fast_valref lr (this->interp, NIL), elem (this->interp);
  bool dot = false;
  uint32_t tok = this->peek ();

  if (tok == TOK_CLOSE)
    {
      this->take ();
      kp_return (*dstp = NIL);
    }
  else if (tok == TOK_SHARPQUOTE)
    {
      *lr = cons::make (this->interp, intern (this->interp, "apply", 5), *lr);
      this->take ();
    }

  for (tok = this->peek (); tok != TOK_CLOSE; )
    {
      *elem = this->read_sexpr (UNBOUND);
      *lr = cons::make (this->interp, *elem, *lr);

      if ((tok = this->peek ()) == TOK_DOT)
        {
          this->take ();
          *elem = this->read_sexpr (UNBOUND);
          if ((tok = this->peek ()) != TOK_CLOSE)
            this->interp->raise ("parse-error",
              "read: elements follow dot in list");
          dot = true;
          break;
        }
      else if (!this->readable_p ())
        raise_eos (this->interp);
    }

  this->take ();
  if (dot)
    *lr = nrevconc (this->interp, *lr, *elem);
  else
    *lr = nreverse_L (this->interp, *lr);

  kp_return (*dstp = *lr);
}

// Backquote implementation.

static bool
bq_member (object elem, object lst)
{
  for (; cons_p (lst); lst = xcdr (lst))
    if (xcar (lst) == elem)
      return (true);

  return (false);
}

[[noreturn]] static inline void
bq_nonlist_splice_err (interpreter *interp, bool dot)
{
  char errmsg[] = "read: the syntax `,@form is invalid";
  if (dot)
    errmsg[19] = '.';

  interp->raise ("parse-error", errmsg);
}

object reader::read_comma (object lbl)
{
  if (this->bq_level <= 0)
    this->interp->raise ("parse-error", "read: more commas than backquotes");

  this->unquoted = true;
  --this->bq_level;

  schar next;
  object head = symbol::comma;

  if (!this->src->sgetc (this->interp, next))
    raise_eos (this->interp);
  else if (*next.buf == '@')
    head = symbol::comma_at;
  else if (*next.buf == '.')
    head = symbol::comma_dot;
  else
    this->src->ungetuc (next.buf, next.len);

  object obj = this->read_sexpr (UNBOUND);
  alloc_cons (this->interp, 2);
  xcar(this->interp->alval) = head;
  xcadr(this->interp->alval) = obj;

  if (lbl != UNBOUND)
    *this->putlbl(lbl) = this->interp->alval;

  ++this->bq_level;
  kp_return (this->interp->alval);
}

object reader::read_bq (object lbl)
{
  bool prev = this->unquoted;
  this->unquoted = false;
  ++this->bq_level;

  object obj = this->read_sexpr (UNBOUND);
  if (cons_p (obj))
    {
      object head = xcar (obj), tst = symbol::comma_at;

      if (head == symbol::comma_at || head == symbol::comma_dot)
        bq_nonlist_splice_err (interp, head == symbol::comma_dot);
      else if (bq_member (tst, obj) ||
          bq_member (tst = symbol::comma_dot, obj))
        {
          char errmsg[] = "read: the syntax `( ... . ,@form) is invalid";
          if (tst == symbol::comma_dot)
            errmsg[27] = '.';

          this->interp->raise ("parse-error", errmsg);
        }
    }
  else if (this->unquoted &&
      !(array_p (obj) || table_p (obj) || tuple_p (obj)))
    this->interp->raise ("parse-error", "read: unquote outside sequence");

  alloc_cons (this->interp, 2);
  xcar(this->interp->alval) = symbol::backquote;
  xcadr(this->interp->alval) = obj;

  if (lbl != UNBOUND)
    *this->putlbl(lbl) = this->interp->alval;

  this->unquoted = prev;
  --this->bq_level;
  kp_return (this->interp->alval);
}

static const object BQ_NCONCABLE = fixint (0) | EXTRA_BIT;

static object
bq_list (interpreter *interp, object form1)
{
  return (KP_CALL (interp, list_fct, intern (interp, "list", 4), form1));
}

static object
bq_transform (interpreter *interp, object form)
{
  if (!cons_p (form))
    {
      valref tmp (interp, expand_bq (interp, form));
      return (bq_list (interp, *tmp));
    }
    
  valref tmp (interp, xcar (form));
  if (*tmp == symbol::comma)
    return (bq_list (interp, *tmp = xcadr (form)));
  else if (*tmp == symbol::comma_at)
    kp_return (xcadr (form));
  else if (*tmp == symbol::comma_dot)
    return (KP_CALL (interp, list_fct, BQ_NCONCABLE, xcadr (form)));
  else if (*tmp == symbol::backquote)
    {
      *tmp = KP_CALL (interp, list_fct, symbol::backquote,
        expand_bq (interp, xcadr (form)));
      return (bq_list (interp, *tmp));
    }
  else
    return (bq_list (interp, *tmp = expand_bq (interp, form)));
}

static object
bq_expand_list (interpreter *interp, object forms)
{
  valref_head h (interp);
  fast_valref ret (interp, NIL), tmp (interp, forms),
              tail (interp);

  while (*tmp != NIL)
    {
      bq_transform (interp, xcar (*tmp));
      *ret = cons::make (interp, interp->retval, *ret);
      *tail = xcdr (*tmp);

      if (*tail == NIL)
        break;
      else if (!xcons_p (*tail))
        {
          *ret = cons::make (interp,
             KP_CALL (interp, list_fct, symbol::backquote, *tail), *ret);
          break;
        }
      else if (xcar (*tail) == symbol::comma)
        {
          *ret = cons::make (interp, xcadr (*tail), *ret);
          break;
        }
      else if (xcar (*tail) == symbol::comma_at ||
           xcar (*tail) == symbol::comma_dot)
        bq_nonlist_splice_err (interp, xcar (*tail) == symbol::comma_dot);
      else
        *tmp = *tail;
    }

  kp_return (*ret);
}
  
static inline bool
bq_splicing_p (interpreter *interp, object form)
{
  valref tmp (interp, form);

  while (true)
    {
      if (!xcons_p (*tmp))
        return (false);
      else if (xcar (*tmp) == symbol::comma)
        *tmp = xcadr (*tmp);
      else
        break;
    }
    
  *tmp = xcar (*tmp);
  return (*tmp == symbol::comma_at || *tmp == symbol::comma_dot);
}

static inline object
bq_non_splicing (interpreter *interp, object form)
{
  if (!bq_splicing_p (interp, form))
    kp_return (form);

  return (KP_CALL (interp, list_fct, intern (interp, "concat", 6), form));
}
      
static inline bool
bq_cons_test (interpreter *interp, object form)
{
  return (xcons_p (form) && xcar (form) == symbol::quote &&
    xcons_p (xcdr (form)) && xcddr (form) == NIL &&
    !bq_splicing_p (interp, xcadr (form)));
}
      
static object
bq_cons (interpreter *interp, object f1, object f2)
{
  valref_head h (interp);
  fast_valref op (interp, intern (interp,
                  bq_splicing_p (interp, f1) ? "list*" : "cons")),
              t2 (interp, f2), t1 (interp, f1);
  
  if (atom_p (*t2))
    return (KP_CALL (interp, list_fct, *op, *t1, *t2));
  else if (xcar (*t2) == intern (interp, "list", 4))
    return (KP_CALL (interp, list_star, xcar (*t2), *t1, xcdr (*t2)));
  else if (bq_cons_test (interp, *t2) && bq_cons_test (interp, *t1))
    return (KP_CALL (interp, list_fct, symbol::quote,
      cons::make (interp, xcadr (*t1), xcadr (*t2))));
  else
    return (KP_CALL (interp, list_fct, *op, *t1, *t2));
}

static object
bq_append (interpreter *interp, object f1, object f2)
{
  valref_head h (interp);
  fast_valref t1 (interp, f1), t2 (interp, f2), aux (interp, NIL),
              lst (interp);
  
  if (*t1 == NIL)
    kp_return (*t2);
  else if (*t2 == NIL)
    kp_return (*t1);
  else if (xcons_p (*t1) && xcar (*t1) == intern (interp, "list", 4) &&
      xcdr (last_L (interp, *t1)) == NIL)
    {
      *t2 = bq_non_splicing (interp, *t2);
      if (xcdr (*t1) == NIL)
        kp_return (*t2);
      else if (xcddr (*t1) == NIL)
        return (bq_cons (interp, *t1 = xcadr (*t1), *t2));
      else
        {
          *t1 = xcdr (*t1), *t2 = cons::make (interp, *t2, NIL);
          *t1 = add_LL (interp, *t1, *t2);
          *t2 = intern (interp, "list*", 5);
          return (cons::make (interp, *t2, *t1));
        }
    }
  else if (bq_cons_test (interp, *t1) && xcons_p (*aux = xcadr (*t1)) &&
      xcdr (last_L (interp, *aux)) == NIL &&
      xcar (*aux) != symbol::comma)
    {
      *t2 = bq_non_splicing (interp, *t2);
      *lst = reverse_L (interp, *aux);
      *aux = *t2;
      
      for (; *lst != NIL; *lst = xcdr (*lst))
        {
          *t1 = KP_CALL (interp, list_fct, symbol::quote, xcar (*lst));
          *aux = bq_cons (interp, *t1, *aux);
        }
        
      kp_return (*aux);
    }
  else if (xcons_p (*t2) && xcar (*t2) ==
      (*aux = intern (interp, "concat", 6)))
    return (KP_CALL (interp, list_star, *aux, *t1, xcdr (*t2)));
  else
    return (KP_CALL (interp, list_fct, intern (interp, "concat", 6), *t1, *t2));
}
    
static object
bq_nconc (interpreter *interp, object f1, object f2)
{
  valref_head h (interp);
  fast_valref t2 (interp, f2);
  
  if (f1 == NIL)
    kp_return (f2);
  else if (f2 == NIL)
    kp_return (f1);
    
  fast_valref lst (interp, intern (interp, "nconcat", 7));
  auto fn = list_fct;
  
  if (xcons_p (*t2) && xcar (*t2) == *lst)
    *t2 = xcdr (*t2), fn = list_star;

  return (KP_CALL (interp, fn, *lst, f1, *t2));
}
      
static object
bq_append_multi (interpreter *interp, object forms)
{
  if (forms == NIL)
    kp_return (forms);
    
  bool nc = false;
  valref_head h (interp);
  fast_valref tf (interp, forms), res (interp, NIL),
              f1 (interp, xcar (*tf)), tmp (interp, NIL);
           
  if (xcons_p (*f1) && xcar (*f1) == BQ_NCONCABLE)
    *res = xcadr (*tf), nc = true;
  else
    *res = *f1;
    
  for (*tf = xcdr (*tf); *tf != NIL; )
    {
      *f1 = xcar (*tf);
      if (xcons_p (*f1) && xcar (*f1) == BQ_NCONCABLE)
        {
          *f1 = xcadr (*f1);
          if (!nc && bq_splicing_p (interp, *res))
            *tmp = KP_CALL (interp, list_fct,
              intern (interp, "concat", 6), *res);
          else
            *tmp = *res;
            
          *res = bq_nconc (interp, *f1, *tmp);
        }
      else
        {
          if (nc && bq_splicing_p (interp, *res))
            *tmp = KP_CALL (interp, list_fct,
              intern (interp, "nconcat", 7), *res);
          else
            *tmp = *res;
            
          *res = bq_append (interp, *f1, *tmp);
        }
        
      nc = false;
      *tf = xcdr (*tf);
    }

  return (bq_non_splicing (interp, *res));
}

static object
seq_to_cons (interpreter *interp, object seq)
{
  valref_head h (interp);
  fast_valref tmp (interp);

  if (array_p (seq))
    {
      const array *ap = as_array (seq);
      if (ap->len == 0)
        kp_return (NIL);

      *tmp = alloc_cons (interp, ap->len);
      for (uint32_t i = 0; i < ap->len; ++i, *tmp = xcdr (*tmp))
        xcar(*tmp) = ap->data[i];

      kp_return (interp->alval);
    }
  else if (table_p (seq))
    {
      *tmp = NIL;
      for (table::iterator it (interp, seq); it.valid (); ++it)
        *tmp = KP_CALL (interp, list_star, it.val (), it.key (), *tmp);

      return (nreverse_L (interp, *tmp));
    }
  else if (tuple_p (seq))
    {
      *tmp = NIL;
      for (tuple::iterator it (interp, seq); it.valid (); ++it)
        *tmp = cons::make (interp, *it, *tmp);

      return (nreverse_L (interp, *tmp));
    }

  kp_return (UNBOUND);
}

object expand_bq (interpreter *interp, object form)
{
  if (form == NIL)
    kp_return (NIL);
  else if (xcons_p (form))
    {
      object tmp = xcar (form);
      if (tmp == symbol::comma)
        kp_return (xcadr (form));
      else if (tmp == symbol::comma_at || tmp == symbol::comma_dot)
        bq_nonlist_splice_err (interp, tmp == symbol::comma_dot);
      else if (tmp == symbol::backquote)
        return (KP_CALL (interp, list_fct, symbol::backquote,
          expand_bq (interp, xcadr (form))));
      else
        {
          valref exp (interp, bq_expand_list (interp, form));
          return (bq_append_multi (interp, *exp));
        }
    }
  else
    {
      valref tmp (interp, seq_to_cons (interp, form));

      if (*tmp == UNBOUND)
        {
          if (!nksymbol_p (form) && !cons_p (form))
            kp_return (form);

          return (KP_CALL (interp, list_fct, symbol::quote, form));
        }

      *tmp = expand_bq (interp, *tmp);

      valref app (interp, intern (interp, "apply", 5));

      if (array_p (form))
        return (KP_CALL (interp, list_fct, *app,
          intern (interp, "array", 5), *tmp));
      else if (table_p (form))
        return (KP_CALL (interp, list_fct, *app,
          intern (interp, "table", 5), NIL, NIL, *tmp));
      else
        return (KP_CALL (interp, list_fct, *app,
          intern (interp, "tuple", 5), NIL, *tmp));
    }
}

object reader::read_sexpr (object lbl)
{
  uint32_t tok = this->peek ();
  this->take ();

  switch (tok)
    {
      case TOK_NONE:
        kp_return (EOS);
      case TOK_CLOSE:
        this->interp->raise ("parse-error", "read: unexpected ')'");
      case TOK_CLOSEB:
        this->interp->raise ("parse-error", "read: unexpected ']'");
      case TOK_CLOSEBRACE:
        this->interp->raise ("parse-error", "read: unexpected '}'");
      case TOK_DOT:
        this->interp->raise ("parse-error", "read: unexpected '.'");

      case TOK_SYM:
      case TOK_NUM:
        return (this->interp->retval);

      case TOK_QUOTE:
        {
          object obj = this->read_sexpr (UNBOUND);
          alloc_cons (this->interp, 2);

          xcar(this->interp->alval) = symbol::quote;
          xcadr(this->interp->alval) = obj;

          if (lbl != UNBOUND)
            *this->putlbl(lbl) = this->interp->alval;

          kp_return (this->interp->alval);
        }

      case TOK_BQ:
        return (this->read_bq (lbl));

      case TOK_COMMA:
        return (this->read_comma (lbl));

      case TOK_OPEN:
        return (this->read_list (lbl));

      case TOK_DQUOTE:
        return (this->read_str ());

      case TOK_OPENB:
        return (this->read_array (lbl));

      case TOK_OPENBRACE:
        return (this->read_table (lbl));

      case TOK_SHARPOPEN:
        return (this->read_tuple (lbl));

      case TOK_SHARPDQUOT:
        return (this->read_bvector ());

      case TOK_CHAR:
        return (this->read_char ());

      case TOK_SHARPQUOTE:
        {
          object obj = this->read_sexpr (UNBOUND);
          if (!nksymbol_p (obj) && !cons_p (obj))
            this->interp->raise ("parse-error", "read: #' "
              "must be used with a symbol or list");

          valref whole (this->interp, alloc_cons (this->interp, 3));
          xcar(*whole) = intern (this->interp, "fct", 3);

          // Set arglist.
          xcadr(*whole) = alloc_cons (this->interp);
          xcar(xcadr (*whole)) = gensym (this->interp, 0, 0);

          // Set body.
          object body = xcar(xcddr (*whole)) = alloc_cons (this->interp, 3);
          xcar(body) = intern (this->interp, "apply", 5);
          xcadr(body) = obj;
          xcar(xcddr (body)) = xcar (xcadr (*whole));

          kp_return (*whole);
        }

      case TOK_SHARPDOT:
        return (eval (this->interp, this->read_sexpr (UNBOUND)));

      case TOK_LABEL:
        {
          if (this->getlbl (this->interp->retval) != UNBOUND)
            this->interp->raise ("parse-error",
              KP_SPRINTF (this->interp, "read: label %Q redefined",
                          this->interp->retval));

          object tmp = this->interp->retval;

          this->read_sexpr (UNBOUND);
          *this->putlbl(tmp) = this->read_sexpr (UNBOUND);
          return (this->interp->retval);
        }

      case TOK_BACKREF:
        {
          object tmp = this->interp->retval;

          this->interp->retval = this->getlbl (tmp);
          if (this->interp->retval == UNBOUND)
            this->interp->raise ("parse-error",
              KP_SPRINTF (this->interp, "read: undefined label %Q", tmp));

          return (this->interp->retval);
        }
    }

  return (this->interp->retval);
}

object reader::read_sexpr ()
{
  try
    {
      return (this->read_sexpr (UNBOUND));
    }
  catch (...)
    {
      this->src->discard ();
      this->take ();
      throw;
    }
}

reader::~reader ()
{
  if (this->pairs.data != this->stpairs)
    xfree (this->pairs.data);
  if (this->bufp != this->stbuf)
    xfree (this->bufp);
}

// String interpolation.

static int
read_fail (interpreter *, stream&, void *, uint32_t)
{
  return (0);
}

static object
read_from_cstr (interpreter *interp, const void *s, int len, const char **endp)
{
  stream instrm;
  bvector bv;

  bv.vo_type = typecode::BVECTOR;
  bv.nbytes = len;

  instrm.rdbuf.init ((char *)s, len);
  instrm.cookie = 0, instrm.ilock = UNBOUND;
  instrm.bvec = bv.as_obj ();

  instrm.pos = fixint (0);
  instrm.vo_full = 0;
  instrm.vo_type = typecode::STREAM;

  stream::xops ops;
  ops.read = read_fail;
  instrm.ops = &ops;
  instrm.io_flags = STRM_UTF8 | STRM_READ | STRM_NOLOCK;

  reader rd (interp, instrm.as_obj ());
  object ret = rd.read_sexpr (UNBOUND);

  if (ret != EOS)
    {
      if (instrm.rdbuf.left () == 0)
        *endp = nullptr;
      else if (isspace (*instrm.rdbuf.curr))
        {
          schar ch;
          rd.nextc (ch);
          instrm.ungetuc (ch.buf, ch.len);
          *endp = instrm.rdbuf.curr;
        }
      else
        *endp = instrm.rdbuf.curr;
    }

  return (ret);
}

static inline const char*
xmemchr (const void *p, int ch, size_t len)
{
  return ((const char *)memchr (p, ch, len));
}

static int
sanitize_fmt (const char *p1, const char *p2)
{
  chmask mask ("0123456789.$'");

  for (; p1 != p2; ++p1)
    if (!mask.tst (*p1))
      return (*p1);

  return (-1);
}

object expand_str (interpreter *interp, object str)
{
  string *sp = as_str (str);
  auto start = (const char *)sp->data;
  int nb = sp->nbytes;
  auto ptr = xmemchr (start, '$', nb);

  if (!ptr)
    kp_return (str);

  stream *ns = strstream (interp,
    alloc_str (interp, 0), STRM_WRITE | STRM_NOLOCK);

  ns->write (interp, start, ptr - start);

  valref_head h (interp);
  fast_valref outs (interp, ns->as_obj ()), args (interp, NIL), elem (interp);

  while (true)
    {
      if (ptr[1] == '$')
        {
          ns->putb (interp, '$');
          const char *tp = xmemchr (ptr += 2, '$', nb -= 2);
          if (!tp)
            {
              ns->write (interp, ptr, sp->nbytes - (ptr - start));
              break;
            }

          ns->write (interp, ptr, tp - ptr);
          nb -= tp - ptr, ptr = tp;
          continue;
        }

      const char *p1 = xmemchr (ptr + 1, '{', nb - (ptr + 1 - start));

      if (!p1)
        interp->raise ("arg-error", "invalid format string "
          "(expected '{' after '$')");

      nb = sp->nbytes - (int)(p1 - start);

      const char *p2 = nullptr;
      *elem = read_from_cstr (interp, p1 + 1, nb - 1, &p2);

      if (!p2 || *p2 != '}')
        interp->raise ("arg-error", "invalid format string "
          "(unbalanced '{}' specifiers)");
      else if (*elem == EOS)
        interp->raise ("arg-error", "invalid format string "
          "(incomplete argument inside '${}')");

      *args = cons::make (interp, *elem, *args);

      {
        int ch = sanitize_fmt (ptr + 1, p1);
        if (ch >= 0)
          {
            char buf[100];
            sprintf (buf, "invalid format specifier: got %c", (char)ch);
            interp->raise ("arg-error", buf);
          }
      }

      ns->write (interp, ptr, p1 - ptr - 1);
      ns->write (interp, "%Q", 2);
      ptr = p2 + 1;

      nb = sp->nbytes - (ptr - start);
      ptr = xmemchr (ptr, '$', nb);
      if (!ptr)
        {
          ns->write (interp, p2 + 1, nb);
          break;
        }

      ns->write (interp, p2 + 1, ptr - p2 - 1);
    }

  if (*args == NIL)
    // Simple string.
    return (sstream_get (interp, ns));

  *args = nreverse_L (interp, *args);
  // The format string must be quoted so that it's not re-evaluated.
  *args = cons::make (interp, KP_CALL (interp, list_fct,
    symbol::quote, sstream_get (interp, ns)), *args);
  *args = cons::make (interp, intern (interp, "%fmt-str"), *args);
  kp_return (*args);
}

static object
backquote_fct (interpreter *interp, object *argv, int)
{
  return (expand_bq (interp, *argv));
}

// (De)serialization definitions.

pack_cache::pack_cache (interpreter *interp) : ref (interp, fixint (0))
{
  for (size_t i = 0; i < KP_NELEM (this->st_tab); ++i)
    this->st_tab[i] = UNBOUND;

  this->l_obj.data = this->st_tab;
  this->l_obj.len = (uint32_t)KP_NELEM (this->st_tab);
  this->n_elem = this->n_old = 0;
  this->evict = true;
  *this->ref = this->l_obj.as_obj ();
}

uint32_t pack_cache::size () const
{
  return (len_a (*this->ref) / 2);
}

object* pack_cache::data ()
{
  return (as_array(*this->ref)->data);
}

static object*
pcache_getptr (interpreter *interp, pack_cache& cache,
  object key, object mask)
{
  uint32_t nprobe = 1, idx = xhash (interp, key) & (cache.size () - 1);
  for (mask = ~mask ; ; )
    {
      object *p = cache.data () + idx * 2;
      if ((*p & mask) == UNBOUND || equal (interp, *p & ~EXTRA_BIT, key))
        return (p);

      idx = (idx + nprobe++) & (cache.size () - 1);
    }
}

object pack_cache::get (interpreter *interp, object key)
{
  object *ptr = pcache_getptr (interp, *this, key, 0);
  if (*ptr == UNBOUND)
    return (*ptr);
  else if ((*ptr & EXTRA_BIT) == 0)
    {
      *ptr |= EXTRA_BIT;
      ++this->n_old;
    }

  return (ptr[1]);
}

static void
pcache_cleanup (pack_cache& cache)
{
  object *data = cache.data ();

  for (uint32_t i = 0; i < cache.l_obj.len; i += 2)
    if (data[i] != UNBOUND && (data[i] & EXTRA_BIT) == 0)
      {
        data[i] = data[i + 1] = UNBOUND | EXTRA_BIT;
        --cache.n_elem;
      }
}

static void
pcache_resize (interpreter *interp, pack_cache& cache)
{
  uint32_t nsize = cache.size () * 2;
  object *data = cache.data ();
  valref nv (interp, alloc_array (interp, nsize * 2));

  for (uint32_t i = 0; i < nsize; i += 2)
    {
      object obj = data[i];
      if ((obj & ~EXTRA_BIT) == UNBOUND)
        continue;

      uint32_t nprobe = 1, idx = xhash (interp, obj) & (nsize - 1);
      while (true)
        {
          if (xaref (*nv, idx * 2) == UNBOUND)
            {
              xaref(*nv, idx * 2 + 0) = obj;
              xaref(*nv, idx * 2 + 1) = data[i + 1];
              break;
            }

          idx = (idx + nprobe++) & (nsize - 1);
        }
    }

  *cache.ref = *nv;
}

static const uint32_t CLEANUP_THRESHOLD = 10 * 1024;

void pack_cache::put (interpreter *interp, object key, object val)
{
  object *ptr = pcache_getptr (interp, *this, key, EXTRA_BIT);
  if (*ptr != UNBOUND)
    return;

  ptr[0] = key, ptr[1] = val;
  if (++this->n_elem * 100 <= this->size () * 75)
    ;
  else if (this->evict && this->n_elem > CLEANUP_THRESHOLD)
    pcache_cleanup (*this);
  else
    pcache_resize (interp, *this);
}

pack_info::pack_info (interpreter *interp, bool use_cache) :
    map (interp, fixint (0)), offset (interp, fixint (0)), errmsg (nullptr)
{
  if (use_cache)
    {
      this->cache = new (this->pcache.ptr ()) pack_cache (interp);
      this->bstream = bvstream (interp, alloc_bvector (interp, 0),
                                STRM_RDWR | STRM_NOLOCK);
    }
  else
    {
      this->cache = nullptr;
      *this->map = KP_CALL (interp, table_fct, NIL, NIL);
    }

}

void pack_info::add_mapping (interpreter *interp, object key, object val)
{
  if (this->cache)
    {
      this->cache->put (interp, key, val);
      return;
    }

  valref tmp (interp, val);
  if (table_get (interp, *this->map, key, UNBOUND, false) == UNBOUND)
    table_put (interp, *this->map, key, *tmp, false);
}

object pack_info::get (interpreter *interp, object obj)
{
  return (this->cache ? this->cache->get (interp, obj) :
    table_get (interp, *this->map, obj, UNBOUND, false));
}

void pack_info::touch (interpreter *interp, int offset)
{
  if (offset < 0)
    return;

  this->bstream->flush (interp);
  as_bvector(this->bstream->extra)->data[offset] |= 0x80;
}

int64_t xpack (interpreter *interp, stream *strm,
  object obj, object *map, size_t nmap)
{
  pack_info info { interp, true };
  for (size_t i = 0; i < nmap; i += 2)
    info.add_mapping (interp, map[i] | EXTRA_BIT, map[i + 1]);

  int64_t rv = xpack (interp, info.bstream, obj, info);
  if (rv < 0 || info.bstream->err_p ())
    return (-1);

  object bv = bvstream_get (interp, info.bstream, true);
  auto ret = strm->write (interp, as_bvector(bv)->data,
                          as_bvector(bv)->nbytes);

  info.bstream->close (interp);
  return (ret);
}

void print_backtrace (interpreter *interp, uint32_t frame,
  stream *strmp, io_info& info)
{
  strmp->write (interp, "Backtrace:\n", 11);
  object tr = interp->stacktrace (frame);

  if (tr == NIL)
    {
      strmp->write (interp, "  #<top-level>\n\n", 16);
      return;
    }

  uint32_t idx = 0;
  info.flags |= io_info::FLG_SAFE;

  for (cons::iterator it (interp, tr); it.valid (); ++it)
    {
      char sbuf[64];
      object vec = *it;
      uint32_t vl;

      strmp->write (interp, sbuf, sprintf (sbuf, "  %d: (", idx++));
      if (!array_p (vec) || (vl = len_a (vec)) == 0)
        {
          strmp->write (interp, "???" ")", 4);
          continue;
        }

      object caller = xaref (vec, 0);

      if (fct_p (caller))
        {
          object nm = fct_name (caller);
          if (nm == NIL)
            strmp->write (interp, "#:fct", 5);
          else
           xwrite (interp, strmp, nm, info);
        }
      else
        strmp->write (interp, "???", 3);

      for (uint32_t i = 1; i < vl; ++i)
        {
          strmp->putb (interp, ' ');
          xwrite (interp, strmp, xaref (vec, i), info);
        }

      strmp->write (interp, ")\n", 2);
    }

  strmp->putb (interp, '\n');
  info.flags &= ~io_info::FLG_SAFE;
}


void write_exc (interpreter *interp, stream *strm, object exc, io_info& info)
{
  try
    {
      write_S (interp, strm, type_name (type (exc)), info);
      strm->write (interp, ": ", 2);
      xwrite (interp, strm, exc, info);
    }
  catch (...)
    {
      strm->write (interp, "failed to write raised value", 28);
    }
}

static int
do_init_io (interpreter *interp)
{
  int ret = init_op::call_deps (interp, &init_symbols);
  if (ret != init_op::result_ok)
    return (ret);

  static native_function backquote_macro;
  auto *bp = ensure_mask (&backquote_macro);

  bp->vo_full = function_base::native_flag;
  bp->vo_type = typecode::FCT;
  bp->fct = backquote_fct;
  bp->min_argc = bp->max_argc = 1;

  object sym = bp->name = intern (interp, "backquote");
  symval(sym) = bp->as_obj ();
  as_symbol(sym)->set_flag (symbol::ctv_flag);

  return (ret);
}

init_op init_io (do_init_io, "io");

KP_DECLS_END

